home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / longMath < prev    next >
Encoding:
Text File  |  1993-06-15  |  7.0 KB  |  329 lines  |  [TEXT/MSET]
  1. \ Long arithmetic.    mrh  Aug 90.
  2.  
  3. \ Jun 92    32-bit 68000 code moved to main dic.  Removed / and /mod from here
  4. \    since main dic versions are now 32-bit.
  5. \ Sept 92    Revised to support the ANSI standard.
  6.  
  7. \ This file implements double-length (64 bit) addition and subtraction, 32*32->64 multiplication and 64/32->32 division, and versions of */ and */MOD which have a 64-bit intermediate result.
  8. \ This behavior is required by the ANSI standard, defined in terms of cells.  It may be overkill for Mops which has 32-bit cells, so we don't put it in the nucleus, but provide it here as an option.
  9.  
  10. :code S>D
  11.         loc
  12.         move    (a6),d0
  13.         bmi.s    mn                ; This is quicker than two EXT's
  14.         clr.l    -(a6)
  15.         rts
  16.  
  17. mn        moveq    #-1,d0
  18.         push.l    d0
  19. ;code
  20.  
  21. :code DNEG
  22.         neg    4(a6)
  23.         negx    (a6)
  24. ;code
  25.  
  26. :code D+
  27.         movem    (a6)+,d0-d2
  28.         add        d1,(a6)
  29.         addx    d0,d2
  30.         push    d2
  31. ;code
  32.  
  33. :code D-
  34.         movem    (a6)+,d0-d2
  35.         sub        d1,(a6)
  36.         subx    d0,d2
  37.         push    d2
  38. ;code
  39.  
  40. :code D<    loc
  41.         movem    (a6)+,d0-d2
  42.         cmp        d0,d2
  43.         blt.s    setTrue
  44.         bgt.s    setFalse
  45.         cmp        (a6),d1
  46.         bhi.s    setTrue
  47.  
  48. setFalse
  49.         clr        (a6)
  50.         rts
  51.  
  52. setTrue    moveq    #-1,d0
  53.         move    d0,(a6)
  54. ;code
  55.  
  56. :code D>
  57.         movem    (a6)+,d0-d2
  58.         cmp        d0,d2
  59.         bgt.s    setTrue
  60.         blt.s    setFalse
  61.         cmp        (a6),d1
  62.         blo.s    setTrue
  63.         bra.s    setFalse
  64. ;code
  65.  
  66. :code D=
  67.         movem    (a6)+,d0-d2
  68.         cmp    d0,d2
  69.         bne.s    setFalse
  70.         cmp    (a6),d1
  71.         bne.s    setFalse
  72.         bra.s    setTrue
  73. ;code
  74.  
  75.  
  76. \ The somewhat dreaded multiply routines
  77.  
  78. :code LONGMULT        ; Subroutine to do long unsigned multiply.  Uses D0-2.
  79.         loc
  80.         pop.l    d0
  81.         move.l    (a6),d1
  82.         clr.l    -(a6)
  83.         move.w    d1,d2
  84.         mulu    d0,d2
  85.         move.l    d2,4(a6)
  86.         move.l    d1,d2
  87.         swap    d2
  88.         mulu    d0,d2
  89.         add.l    d2,2(a6)
  90.         swap    d0
  91.         move.w    d1,d2
  92.         mulu    d0,d2
  93.         add.l    d2,2(a6)
  94.         bcc.s    mpy2
  95.         addq.w    #1,(a6)
  96. mpy2    move.l    d1,d2
  97.         swap    d2
  98.         mulu    d0,d2
  99.         add.l    d2,(a6)
  100. ;code
  101.  
  102.  
  103. :code UM*        ; Unsigned mixed multiply
  104.         loc
  105.         bra.s    p68k              ; NOP'd out if we're on an 020/030 or later
  106.  
  107.         pop.l    d1
  108.         dc.w    $4C16,$1400        ; mulu.l  (a6),d0:d1
  109.         move.l    d1,(a6)
  110.         push.l    d0
  111.         rts
  112.  
  113. p68k    tst.w    (a6)            ; If both high-order words are zero,
  114.         bne.s    dic[longMult]    ;  we can do a short multiply.
  115.         tst.w    4(a6)
  116.         bne.s    dic[longMult]
  117.         pop.l    d0                ; Yes, we can.
  118.         move.l    (a6),d1
  119.         mulu    d0,d1
  120.         move.l    d1,(a6)
  121.         clr.l    -(a6)
  122. ;code
  123.  
  124.  
  125. :code M*        ; Signed mixed multiply
  126.         loc
  127.         bra.s    p68k              ; NOP'd out if we're on an 020/030 or later
  128.  
  129.         pop.l    d1
  130.         dc.w    $4C16,$1C00        ; muls.l  (a6),d0:d1
  131.         move.l    d1,(a6)
  132.         push.l    d0
  133.         rts
  134.  
  135. p68k    move.l    d3,-(a7)        ; save D3
  136.         tst.l    (a6)
  137.         smi        d3
  138.         bpl.s    tst2nd
  139.         neg.l    (a6)
  140. tst2nd    tst.l    4(a6)
  141.         bpl.s    domult
  142.         not.b    d3
  143.         neg.l    4(a6)
  144. domult    bsr.s    dic[um*]
  145.         tst.b    d3
  146.         beq.s    done
  147.         neg.l    4(a6)
  148.         negx    (a6)
  149. done    move.l    (a7)+,d3        ; restore d3
  150. ;code
  151.  
  152.  
  153. \ Division.
  154.  
  155. : DIV_OVERFLOW    24 ArithErr  ;
  156. : ZERO_DIV        25 ArithErr  ;
  157.  
  158.  
  159. :code  UM/MOD    ; Unsigned mixed division.  Code lifted
  160.                 ; from yours truly's PDP-11 implementation,
  161.                 ; which I prefer to the original Neon version.
  162.         loc
  163.         bra.s    ummod            ; NOP'd out if we're on an 020/030 or later
  164.  
  165.         movem.l    (a6)+,d0-d2        ; Divisor to D0, dividend to D1-2
  166.         dc.w    $4C40,$2401        ; divu.l  d0,d1:d2
  167.         push.l    d1                ; Push remainder
  168.         push.l    d2                ; Push quotient
  169.         rts
  170.  
  171. ummod    tst.l    (a6)
  172.         beq.s    dic[zero_div]    ; Check for zero divide
  173.         tst.l    4(a6)            ; Top 32 bits of dividend zero?
  174.         bne.s    longdiv
  175.         move.l    (a6)+,(a6)        ; Yes - NIP them and call U/MOD (faster)
  176.         jmp    dic[u/mod]
  177.  
  178. longdiv    pop.l    d2    ; D2 = divisor
  179.         pop.l    d0
  180.         move.l    (a6),d1    ; D0/1 = dividend
  181.         cmp.l    d2,d0
  182.         bhs.s    dic[div_overflow]
  183.         move.l    d3,-(a7)
  184.         moveq    #31,d3
  185.  
  186. loop    asl.l    #1,d1
  187.         roxl.l    #1,d0
  188.         bcs.s    dosub
  189.         cmp.l    d2,d0
  190.         blo.s    lptest
  191. dosub    sub.l    d2,d0
  192.         addq    #1,d1
  193. lptest    dbra    d3,loop
  194.  
  195.         move.l    (a7)+,d3
  196.         move.l    d0,(a6)            ; Push remainder
  197.         push.l    d1                ; and quotient
  198. ;code
  199.  
  200.  
  201. :code  M/MOD  ; ( d n -- rem quot )  Signed mixed division
  202.  
  203.         bra.s    p68k            ; NOP'd out if we're on an 020/030 or later
  204.  
  205.         movem.l    (a6)+,d0-d2        ; Divisor to D0, dividend to D1-2
  206.         dc.w    $4C40,$2C01        ; divs.l  d0,d1:d2
  207.         push.l    d1                ; Push remainder
  208.         push.l    d2                ; Push quotient
  209.         rts
  210.  
  211. p68k    movem.l    d3-d4,-(a7)        ; Save regs
  212.         tst.l    (a6)            ; We make everything
  213.         smi    d3                    ; positive then call um/mod.
  214.         bpl.s    mm1
  215.         neg.l    (a6)
  216. mm1        tst.l    4(a6)
  217.         smi    d4
  218.         bpl.s    mm2
  219.         neg.l    8(a6)
  220.         negx.l    4(a6)
  221.  
  222. mm2        bsr.s    ummod
  223.         tst.l    4(a6)
  224.         bmi    dic[div_overflow]
  225.         eor.b    d4,d3            ; Set sign of quotient
  226.         bpl.s    mm3
  227.         neg.l    (a6)
  228. mm3        tst.b    d4                ; Set sign of remainder - same as dividend,
  229.         bpl.s    rtn                ; which is different from original Neon.
  230.         neg.l    4(a6)            ; Yes, this was a bug!
  231. rtn        movem.l    (a7)+,d3-d4        ; Restore regs and return
  232. ;code
  233.  
  234.  
  235. : */MOD        >r  m*  r>  m/mod  ;
  236.  
  237. : */        */mod  nip  ;
  238.  
  239. : UMD/MOD  { dndL dndH dsr \ quotH -- rem quotL quotH }
  240.     dndL
  241.     dndH 0  dsr  um/mod  -> quotH
  242.     ( dndL rem1 ) dsr  um/mod  quotH  ;
  243.  
  244.  
  245. \ FM/MOD and SM/REM are the ANSI division words forcing floored and symmetric
  246. \ division respectively.  The 680x0 signed division is symmetric, so that
  247. \ is, naturally, the Mops default (defined by M/MOD).  For FM/MOD we have
  248. \ to do a little work.
  249.  
  250. : SM/REM    \ ( d n -- rem quot )
  251.     m/mod  ;
  252.  
  253. \ FM/MOD  ( d n -- mod quot )
  254. \ If the signs of the divisor and dividend are the same, the result is
  255. \ identical to SM/REM (i.e. M/MOD), as it is if the signs differ but
  256. \ the remainder from calling M/MOD is zero.  If the remainder is non-zero,
  257. \ we need to adjust by subtracting 1 from the quotient, and adding the
  258. \ divisor to the remainder.  This works whichever way around the signs are.
  259.  
  260. :code  FM/MOD
  261.         loc
  262.         move.l    (a6),d0
  263.         move.l    4(a6),d1
  264.         eor.l    d0,d1
  265.         bpl        dic[m/mod]        ; Signs same - call M/MOD and out.
  266.         move.l    (a6),-(a7)        ; Signs differ.  Save divisor
  267.         bsr        dic[m/mod]        ; Call M/MOD
  268.         move.l    (a7)+,d0        ; Recover divisor to D0
  269.         tst.l    4(a6)            ; Remainder zero?
  270.         beq.s    out                ; Yes - we're finished.
  271.         subq.l    #1,(a6)            ; No - do adjustment.
  272.         add.l    d0,4(a6)
  273. out
  274. ;code
  275.  
  276.  
  277. \ NumAccumulate ( ud1 digit -- ud2 ) is a vector called by >NUMBER.  It
  278. \ multiplies ud1 by BASE, then adds the digit.  In the nucleus we don't
  279. \ implement double-length arithmetic, so we ignore the hi cell of ud1,
  280. \ and put zero in the hi cell of ud2.  Here we implement a proper
  281. \ double-length version.
  282.  
  283. : (NumAcc)  { udL udH dig \ prod1H -- ud2 }
  284.         udL base um*  -> prod1H
  285.         udH base *  prod1H +
  286.         dig 0  d+  ;
  287.  
  288. ' (numAcc)  -> NumAccumulate
  289.  
  290.  
  291. \ # in the nucleus ignores the hi cell of the double operand.  Here
  292. \ we provide a real double version.
  293.  
  294. : #
  295.     base  umd/mod  rot 9 over <
  296.     IF    7 +  THEN
  297.     $ 30 +  hold  ;
  298.     
  299. : #S
  300.     BEGIN  #  2dup or  NUNTIL  ;
  301.  
  302. \ Call initLongMath before using any LongMath words.  At present all it
  303. \ does is to test what processor we're running on, and patch the words to
  304. \ use the 020/030 long mult and div instructions if they exist.  This will
  305. \ improve the performance significantly.
  306.  
  307. : INITLONGMATH  { \ nop -- }
  308.     processor  2 <= ?EXIT        \ Out if 68000/68010
  309.     $ 4E71  -> nop
  310.     nop  ['] um*    w!
  311.     nop  ['] m*    w!
  312.     nop  ['] um/mod    w!
  313.     nop  ['] m/mod    w!
  314.     patches_done  ;
  315.     
  316. ' initLongMath  add: init_actions
  317.  
  318. endload
  319.  
  320. \ Comment out the endload for Neon compatibility.  We've used ANSI Forth
  321. \ word names, but these are redefined to their Neon equivalents below.
  322. \ I hope you don't find these various word names as confusing as I do.
  323.  
  324. : S->D    s>d  ;
  325. : U*    um*  ;
  326. : U/    um/mod  ;
  327. : M/    m/mod  ;
  328. : M/MOD    umd/mod  ;
  329.